home *** CD-ROM | disk | FTP | other *** search
/ EnigmA Amiga Run 1996 March / EnigmA AMIGA RUN 05 (1996)(G.R. Edizioni)(IT)[!][issue 1996-03][Skylink CD IV].iso / earcd / program / mui32dev.lha / MUI / Developer / Modula / Demo / Class2.mod < prev    next >
Text File  |  1995-11-18  |  13KB  |  434 lines
  1. MODULE Class2 ;
  2.  
  3. (*
  4. ** Class2.mod by Olaf "Olf" Peters <olf@informatik.uni-bremen.de>
  5. **
  6. ** based upon Class2.c by Stefan Stuntz.
  7. **
  8. ** IMPORTANT: RangeChk mußt be switched off, otherwise you'll get an error
  9. ** when entering the Colorwheel-Page!
  10. *)
  11.  
  12. (*$ RangeChk := FALSE *)
  13.  
  14. FROM SYSTEM     IMPORT  TAG, ADR, ADDRESS, LONGSET, CAST, SETREG, REG ;
  15. FROM AmigaLib   IMPORT  DoSuperMethodA ;
  16. FROM ExecL      IMPORT  Wait ;
  17.  
  18. IMPORT
  19.         R,
  20.         gd  : GraphicsD,
  21.         gl  : GraphicsL,
  22.         id  : IntuitionD,
  23.         il  : IntuitionL,
  24.         m   : MuiD,
  25.         mc  : MuiClasses,
  26.         ml  : MuiL,
  27.         mm  : MuiMacros,
  28.         ms  : MuiSupport,
  29.         ud  : UtilityD,
  30.         ul  : UtilityL ;
  31.  
  32. (***************************************************************************)
  33. (* Here is the beginning of our simple new class...                        *)
  34. (***************************************************************************)
  35.  
  36. (*
  37. ** This class is the same as within Class1.c except that it features
  38. ** a pen attribute.
  39. *)
  40.  
  41. TYPE
  42.   LongcardPtr = POINTER TO LONGCARD ;
  43.  
  44.   Data = RECORD
  45.            penspec   : m.mPenSpec ;
  46.            pen       : ADDRESS;
  47.            penchange : BOOLEAN ;
  48.          END (* RECORD *) ;
  49.  
  50. CONST
  51.   MyAttrPen = LONGCARD(8022H) ; (* tag value for the new attribute.            *)
  52.  
  53. (*/// "mNew(cl : id.IClassPtr; obj : id.ObjectPtr; msg : id.OpSetPtr) : ADDRESS" *)
  54.  
  55. PROCEDURE mNew(cl : id.IClassPtr; obj : id.ObjectPtr; msg : id.OpSetPtr) : ADDRESS ;
  56.  
  57. VAR
  58.   data  : POINTER TO Data ;
  59.   tag,
  60.   tags  : ud.TagItemPtr ;
  61.  
  62. BEGIN
  63.   obj := DoSuperMethodA(cl, obj, msg) ;
  64.   IF obj = NIL THEN RETURN NIL END ;
  65.  
  66.   data := mc.InstData(cl, obj) ;
  67.  
  68.   (* parse initial taglist *)
  69.  
  70.   tags := msg^.attrList ;
  71.   tag  := ul.NextTagItem(tags) ;
  72.   WHILE tag # NIL DO
  73.     CASE tag^.tag OF
  74.     | MyAttrPen : IF tag^.data # 0 THEN
  75.                     data^.penspec := CAST(m.mPenSpecPtr, tag^.data)^ ;
  76.                   END (* IF *) ;
  77.     ELSE
  78.     END (* CASE *) ;
  79.     tag := ul.NextTagItem(tags) ;
  80.   END (* WHILE *) ;
  81.  
  82.   RETURN obj ;
  83. END mNew ;
  84.  
  85. (*\\\*)
  86. (*/// "mDispose(cl : id.IClassPtr; obj : id.ObjectPtr; msg : ADDRESS) : ADDRESS" *)
  87.  
  88. PROCEDURE mDispose(cl : id.IClassPtr; obj : id.ObjectPtr; msg : ADDRESS) : ADDRESS ;
  89.  
  90. BEGIN
  91.   (* OM_NEW didnt allocates something, just do nothing here... *)
  92.   RETURN DoSuperMethodA(cl, obj, msg) ;
  93. END mDispose ;
  94.  
  95. (*\\\*)
  96.  
  97. (*
  98. ** OM_SET method, we need to see if someone changed the penspec attribute.
  99. *)
  100.  
  101. (*/// "mSet(cl : id.IClassPtr; obj : id.ObjectPtr; msg : id.OpSetPtr) : ADDRESS" *)
  102.  
  103. PROCEDURE mSet(cl : id.IClassPtr; obj : id.ObjectPtr; msg : id.OpSetPtr) : ADDRESS ;
  104.  
  105. VAR
  106.   data : POINTER TO Data ;
  107.   tag,
  108.   tags : ud.TagItemPtr ;
  109.  
  110. BEGIN
  111.   data := mc.InstData(cl, obj) ;
  112.  
  113.   tags := msg^.attrList ;
  114.   tag  := ul.NextTagItem(tags) ;
  115.   WHILE tag # NIL DO
  116.     CASE tag^.tag OF
  117.     | MyAttrPen : IF tag^.data # 0 THEN
  118.                     data^.penspec   := CAST(m.mPenSpecPtr, tag^.data)^ ;
  119.                     data^.penchange := TRUE ;
  120.                     IF ml.moRedraw(obj, CAST(LONGCARD, mc.MADFlagSet{mc.drawObject})) # NIL THEN END ;
  121.                   END (* IF *) ;
  122.     ELSE
  123.     END (* CASE *) ;
  124.     tag := ul.NextTagItem(tags) ;
  125.   END (* WHILE *) ;
  126.  
  127.   RETURN DoSuperMethodA(cl, obj, msg) ;
  128. END mSet ;
  129.  
  130. (*\\\*)
  131.  
  132. (*
  133. ** OM_GET method, see if someone wants to read the color.
  134. *)
  135.  
  136. (*/// "mGet(cl : id.IClassPtr; obj : id.ObjectPtr; msg : id.OpGetPtr) : ADDRES" *)
  137.  
  138. PROCEDURE mGet(cl : id.IClassPtr; obj : id.ObjectPtr; msg : id.OpGetPtr) : ADDRESS;
  139.  
  140. VAR
  141.   data  : POINTER TO Data ;
  142.   store : LongcardPtr ;
  143.  
  144. BEGIN
  145.   data := mc.InstData(cl, obj) ;
  146.   store := CAST(LongcardPtr, msg^.storage) ;
  147.  
  148.   CASE msg^.attrID OF
  149.   | MyAttrPen : store^ := ADR(data^.penspec) ;
  150.                 RETURN LONGCARD(TRUE) ;
  151.   ELSE
  152.     RETURN DoSuperMethodA(cl, obj, msg) ;
  153.   END (* CASE *) ;
  154. END mGet ;
  155.  
  156. (*\\\*)
  157. (*/// "mSetup(cl : id.IClassPtr; obj : id.ObjectPtr; msg : id.OpSetPtr) : ADDRES" *)
  158.  
  159. PROCEDURE mSetup(cl : id.IClassPtr; obj : id.ObjectPtr; msg : id.OpSetPtr) : ADDRESS;
  160.  
  161. VAR
  162.   data : POINTER TO Data ;
  163.   test : ADDRESS ;
  164.  
  165. BEGIN
  166.   data := mc.InstData(cl, obj) ;
  167.  
  168.   IF DoSuperMethodA(cl, obj, msg) = NIL THEN
  169.     RETURN LONGCARD(FALSE) ;
  170.   END (* IF *) ;
  171.  
  172.   test := mc.muiRenderInfo(obj) ;
  173.   data^.pen := ml.moObtainPen(mc.muiRenderInfo(obj), ADR(data^.penspec)) ;
  174.  
  175.   RETURN LONGCARD(TRUE) ;
  176. END mSetup ;     
  177.  
  178. (*\\\*)
  179. (*/// "mCleanup(cl : id.IClassPtr; obj : id.ObjectPtr; msg : id.OpSetPtr) : ADDRES" *)
  180.  
  181. PROCEDURE mCleanup(cl : id.IClassPtr; obj : id.ObjectPtr; msg : id.OpSetPtr) : ADDRESS;
  182.  
  183. VAR
  184.   data :POINTER TO Data ;
  185.  
  186. BEGIN
  187.   data := mc.InstData(cl, obj) ;
  188.   ml.moReleasePen(mc.muiRenderInfo(obj), data^.pen) ;
  189.   RETURN DoSuperMethodA(cl, obj, msg) ;
  190. END mCleanup ;
  191.  
  192. (*\\\*)
  193. (*/// "mAskMinMax(cl : id.IClassPtr; obj : id.ObjectPtr; msg : mc.mpAskMinMaxPtr) : ADDRES" *)
  194.  
  195. PROCEDURE mAskMinMax(cl : id.IClassPtr; obj : id.ObjectPtr; msg : mc.mpAskMinMaxPtr) : ADDRESS;
  196.  
  197. BEGIN
  198.   (*
  199.   ** let our superclass first fill in what it thinks about sizes.
  200.   ** this will e.g. add the size of frame and inner spacing.
  201.   *)
  202.  
  203.   IF DoSuperMethodA(cl, obj, msg) # NIL THEN END ;
  204.  
  205.   (*
  206.   ** now add the values specific to our object. note that we
  207.   ** indeed need to *add* these values, not just set them!
  208.   *)
  209.  
  210.   INC(msg^.MinMaxInfo^.MinWidth, 100) ;
  211.   INC(msg^.MinMaxInfo^.DefWidth, 120) ;
  212.   INC(msg^.MinMaxInfo^.MaxWidth, 500) ;
  213.  
  214.   INC(msg^.MinMaxInfo^.MinHeight, 40) ;
  215.   INC(msg^.MinMaxInfo^.DefHeight, 90) ;
  216.   INC(msg^.MinMaxInfo^.MaxHeight, 300) ;
  217.  
  218.   RETURN NIL ;
  219. END mAskMinMax ;
  220.  
  221. (*\\\*)
  222.  
  223. (*
  224. ** Draw method is called whenever MUI feels we should render
  225. ** our object. This usually happens after layout is finished
  226. ** or when we need to refresh in a simplerefresh window.
  227. ** Note: You may only render within the rectangle
  228. **       _mleft(obj), _mtop(obj), _mwidth(obj), _mheight(obj).
  229. *)
  230.  
  231. (*/// "mDraw(cl : id.IClassPtr; obj : id.ObjectPtr; msg : mc.mpDraw) : ADDRES" *)
  232.  
  233. PROCEDURE mDraw(cl : id.IClassPtr; obj : id.ObjectPtr; msg : mc.mpDrawPtr) : ADDRESS;
  234.  
  235. VAR
  236.   data : POINTER TO Data ;
  237.   i    : INTEGER ;
  238.  
  239. BEGIN
  240.   data := mc.InstData(cl, obj) ;
  241.  
  242.   (*
  243.   ** let our superclass draw itself first, area class would
  244.   ** e.g. draw the frame and clear the whole region. What
  245.   ** it does exactly depends on msg->flags.
  246.   *)
  247.  
  248.   IF DoSuperMethodA(cl, obj, msg) # NIL THEN END ;
  249.  
  250.   (*
  251.   ** if MADF_DRAWOBJECT isn't set, we shouldn't draw anything.
  252.   ** MUI just wanted to update the frame or something like that.
  253.   *)
  254.  
  255.   IF NOT (mc.drawObject IN msg^.flags) THEN RETURN NIL END ;
  256.  
  257.   (*
  258.   ** test if someone changed our pen
  259.   *)
  260.  
  261.   IF data^.penchange THEN
  262.     data^.penchange := FALSE ;
  263.     ml.moReleasePen(mc.muiRenderInfo(obj), data^.pen) ;
  264.     data^.pen := ml.moObtainPen(mc.muiRenderInfo(obj), ADR(data^.penspec)) ;
  265.   END (* IF *) ;
  266.  
  267.   (*
  268.   ** ok, everything ready to render...
  269.   ** Note that we *must* use the MUIPEN() macro before actually
  270.   ** using pens from MUI_ObtainPen() in rendering calls.
  271.   *)
  272.  
  273.   gl.SetAPen(mc.OBJ_rp(obj),mc.muiPen(data^.pen));
  274.  
  275.   FOR i := mc.OBJ_mleft(obj) TO mc.OBJ_mright(obj) BY 5 DO
  276.     gl.Move(mc.OBJ_rp(obj),mc.OBJ_mleft(obj),mc.OBJ_mtop(obj));
  277.     gl.Draw(mc.OBJ_rp(obj),i,mc.OBJ_mbottom(obj));
  278.     gl.Move(mc.OBJ_rp(obj),mc.OBJ_mright(obj),mc.OBJ_mtop(obj));
  279.     gl.Draw(mc.OBJ_rp(obj),i,mc.OBJ_mbottom(obj));
  280.   END (* FOR *) ;
  281.  
  282.   RETURN NIL ;
  283. END mDraw ;
  284.  
  285. (*\\\*)
  286.  
  287. (*
  288. ** Here comes the dispatcher for our custom class. We only need to
  289. ** care about MUIM_AskMinMax and MUIM_Draw in this simple case.
  290. ** Unknown/unused methods are passed to the superclass immediately.
  291. *)
  292.  
  293. (*/// "MyDispatcher(cl : id.IClassPtr; obj : ADDRESS; msg : ADDRESS) : ADDRESS" *)
  294.  
  295. PROCEDURE MyDispatcher(cl : id.IClassPtr; obj : ADDRESS; msg : ADDRESS) : ADDRESS ;
  296.  
  297. VAR
  298.   mid : LONGCARD ;
  299.  
  300. BEGIN
  301.   mid := CAST(id.Msg, msg)^.methodID ;
  302.  
  303.      IF mid = id.omNEW      THEN RETURN mNew(cl, obj, msg)
  304.   ELSIF mid = id.omDISPOSE  THEN RETURN mDispose(cl, obj, msg)
  305.   ELSIF mid = id.omSET      THEN RETURN mSet(cl, obj, msg)
  306.   ELSIF mid = id.omGET      THEN RETURN mGet(cl, obj, msg)
  307.   ELSIF mid = m.mmAskMinMax THEN RETURN mAskMinMax(cl, obj, msg)
  308.   ELSIF mid = m.mmSetup     THEN RETURN mSetup(cl, obj, msg)
  309.   ELSIF mid = m.mmCleanup   THEN RETURN mCleanup(cl, obj, msg)
  310.   ELSIF mid = m.mmDraw      THEN RETURN mDraw(cl, obj, msg)
  311.   ELSE
  312.     RETURN DoSuperMethodA(cl, obj, msg)
  313.   END (* CASE *) ;
  314. END MyDispatcher ;
  315.  
  316. (*\\\*)
  317.  
  318. (***************************************************************************)
  319. (* Thats all there is about it. Now lets see how things are used...        *)
  320. (***************************************************************************)
  321.  
  322. VAR
  323.   app,
  324.   window,
  325.   grp,
  326.   myObj,
  327.   pen      : id.ObjectPtr ;
  328.   mcc      : mc.mCustomClassPtr ;
  329.   signals  : LONGSET ;
  330.   running  := BOOLEAN{TRUE} ;
  331.   startpen : m.mPenSpecPtr ;
  332.   NULL     :=ADDRESS{NIL};
  333.   myDispatcher : ADDRESS ;
  334.  
  335.   tags     : ARRAY [0..31] OF LONGINT ;
  336.   tags1    : ARRAY [0..7]  OF LONGINT ;
  337.  
  338. BEGIN
  339.   (* Create the new custom class with a call to MUI_CreateCustomClass(). *)
  340.   (* Caution: This function returns not a struct IClass, but a           *)
  341.   (* struct MUI_CustomClass which contains a struct IClass to be         *)
  342.   (* used with NewObject() calls.                                        *)
  343.   (* Note well: MUI creates the dispatcher hook for you, you may         *)
  344.   (* *not* use its h_Data field! If you need custom data, use the        *)
  345.   (* cl_UserData of the IClass structure!                                *)
  346.  
  347.   IF ml.muiMasterVersion < 12 THEN ms.fail(NULL, "You need MUI 3.1 to run this demo.") END;
  348.  
  349.   myDispatcher := ADR(myDispatcher) ;
  350.   mcc := ml.moCreateCustomClass(NIL, ADR(m.mcArea), NIL, SIZE(Data), myDispatcher) ;
  351.   IF mcc = NIL THEN ms.fail(NULL, "Could not create custom class.") END ;
  352.  
  353.   mc.MakeDispatcher(MyDispatcher, mcc^.class) ;
  354.  
  355.   pen := mm.PoppenObject(TAG(tags, m.maCycleChain, TRUE,
  356.                                    m.maWindowTitle, ADR("Custom Class Color"),
  357.                              ud.tagDone)) ;
  358.  
  359.   myObj := il.NewObjectA(mcc^.class, NIL, TAG(tags, m.maFrame,      m.mvFrameText,
  360.                                                     m.maBackground, m.miBACKGROUND,
  361.                                               ud.tagDone)) ;
  362.  
  363.   grp := mm.GroupObject(TAG(tags, m.maGroupHoriz,  FALSE,
  364.                                   mm.Child,        mm.TextObject(TAG(tags1, m.maFrame, m.mvFrameText,
  365.                                                                             m.maBackground, m.miTextBack,
  366.                                                                             m.maTextContents, ADR("\ecThis is a custom class with attributes.\nClick on the button at the bottom of\nthe window to adjust the color."),
  367.                                                                      ud.tagDone)),
  368.                                   mm.Child,        myObj,
  369.                                   mm.Child,        mm.GroupObject(TAG(tags1, m.maWeight, 10,
  370.                                                                              mm.Child, mm.FreeLabel(ADR("Custom Class Color:")),
  371.                                                                              mm.Child, pen,
  372.                                                                       ud.tagDone)),
  373.  
  374.                             ud.tagDone)) ;
  375.  
  376.   window := mm.WindowObject(TAG(tags, m.maWindowTitle, ADR("Another Custom Class"),
  377.                                       m.maWindowID,    mm.MakeID("CLS2"),
  378.                                       mm.WindowContents, grp,
  379.                                 ud.tagDone)) ;
  380.  
  381.   app := mm.ApplicationObject(TAG(tags, m.maApplicationTitle,       ADR("Class2-M2"),
  382.                                         m.maApplicationVersion,     ADR("$VER: Class2-M2 11.1 (21.9.95)"),
  383.                                         m.maApplicationCopyright,   ADR("©1995, Olaf Peters, Stefan Stuntz"),
  384.                                         m.maApplicationAuthor,      ADR("Olaf Peters, Stefan Stuntz"),
  385.                                         m.maApplicationDescription, ADR("Demonstrate the use of custom classes."),
  386.                                         m.maApplicationBase,        ADR("CLASS2M2"),
  387.                                         mm.SubWindow,               window,
  388.                                   ud.tagDone)) ;
  389.  
  390.   IF app = NIL THEN ms.fail(NULL, "Failed to create Application.") END ;
  391.  
  392.   mm.NoteClose(app, window, m.mvApplicationReturnIDQuit) ;
  393.  
  394.   ms.DoMethod(pen,TAG(tags, m.mmNotify, m.maPendisplaySpec, m.mvEveryTime,
  395.                          myObj, 3, m.mmSet, MyAttrPen, m.mvTriggerValue,
  396.                    ud.tagDone));
  397.  
  398.   mm.get(pen, m.maPendisplaySpec, ADR(startpen)) ;
  399.   mm.set(myObj, MyAttrPen, LONGCARD(startpen)) ;
  400.  
  401. (*
  402. ** Input loop...
  403. *)
  404.  
  405.   mm.set(window, m.maWindowOpen, LONGCARD(TRUE)) ;
  406.  
  407.   WHILE running DO
  408.     CASE ms.DOMethod(app, TAG(tags, m.mmApplicationInput, ADR(signals), ud.tagDone)) OF
  409.     | m.mvApplicationReturnIDQuit : running := FALSE ;
  410.     ELSE
  411.     END (* CASE *) ;
  412.     IF running AND (signals # LONGSET{}) THEN
  413.       signals := Wait(signals) ;
  414.     END (* IF *) ;
  415.   END (* WHILE *) ;
  416.  
  417.   mm.set(window, m.maWindowOpen, LONGCARD(FALSE)) ;
  418.  
  419. (*
  420. ** Shut down...
  421. *)
  422.  
  423. CLOSE
  424.   IF app # NIL THEN
  425.     ml.mDisposeObject(app) ;
  426.     app := NIL ;
  427.   END (* IF *) ;
  428.  
  429.   IF mcc # NIL THEN
  430.     IF ml.moDeleteCustomClass(mcc) THEN END ;
  431.     mcc := NIL ;
  432.   END (* IF *) ;
  433. END Class2.
  434.